home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / gnu / emacs / emacs1857 / bin_d2.zoo / lisp / disass.el < prev    next >
Lisp/Scheme  |  1991-12-02  |  12KB  |  447 lines
  1. ;;; Disassembler for compiled Emacs Lisp code
  2. ;; Copyright (C) 1986 Free Software Foundation
  3. ;;; By Doug Cutting (doug@csli.stanford.edu)
  4.  
  5. ;; This file is part of GNU Emacs.
  6.  
  7. ;; GNU Emacs is free software; you can redistribute it and/or modify
  8. ;; it under the terms of the GNU General Public License as published by
  9. ;; the Free Software Foundation; either version 1, or (at your option)
  10. ;; any later version.
  11.  
  12. ;; GNU Emacs is distributed in the hope that it will be useful,
  13. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15. ;; GNU General Public License for more details.
  16.  
  17. ;; You should have received a copy of the GNU General Public License
  18. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  19. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21.  
  22. (require 'byte-compile "bytecomp")
  23.  
  24. (defvar disassemble-column-1-indent 4 "*")
  25.  
  26. (defvar disassemble-column-2-indent 9 "*")
  27.  
  28. (defvar disassemble-recursive-indent 3 "*")
  29.  
  30. ;(defun d (x)
  31. ;  (interactive "xDiss ")
  32. ;  (with-output-to-temp-buffer "*Disassemble*"
  33. ;    (disassemble-internal (list 'lambda '() x ''return-value)
  34. ;              standard-output 0 t)))
  35.  
  36. (defun disassemble (object &optional stream indent interactive-p)
  37.   "Print disassembled code for OBJECT on (optional) STREAM.
  38. OBJECT can be a function name, lambda expression or any function object
  39. returned by SYMBOL-FUNCTION.  If OBJECT is not already compiled, we will
  40. compile it (but not redefine it)."
  41.   (interactive (list (intern (completing-read "Disassemble function: "
  42.                           obarray 'fboundp t))
  43.              nil 0 t))
  44.   (or indent (setq indent 0))        ;Default indent to zero
  45.   (if interactive-p
  46.       (with-output-to-temp-buffer "*Disassemble*"
  47.     (disassemble-internal object standard-output indent t))
  48.     (disassemble-internal object (or stream standard-output) indent nil))
  49.   nil)
  50.  
  51. (defun disassemble-internal (obj stream indent interactive-p)
  52.   (let ((macro 'nil)
  53.     (name 'nil)
  54.     (doc 'nil)
  55.     args)
  56.     (while (symbolp obj)
  57.       (setq name obj
  58.         obj (symbol-function obj)))
  59.     (if (subrp obj)
  60.     (error "Can't disassemble #<subr %s>" name))
  61.     (if (eq (car obj) 'macro)        ;handle macros
  62.     (setq macro t
  63.           obj (cdr obj)))
  64.     (if (not (eq (car obj) 'lambda))
  65.     (error "not a function"))
  66.     (if (assq 'byte-code obj)
  67.     nil
  68.       (if interactive-p (message (if name
  69.                      "Compiling %s's definition..."
  70.                      "Compiling definition...")
  71.                  name))
  72.       (setq obj (byte-compile-lambda obj))
  73.       (if interactive-p (message "Done compiling.  Disassembling...")))
  74.     (setq obj (cdr obj))        ;throw lambda away
  75.     (setq args (car obj))        ;save arg list
  76.     (setq obj (cdr obj))
  77.     (write-spaces indent stream)
  78.     (princ (format "byte code%s%s%s:\n"
  79.            (if (or macro name) " for" "")
  80.            (if macro " macro" "")
  81.            (if name (format " %s" name) ""))
  82.        stream)
  83.     (let ((doc (and (stringp (car obj)) (car obj))))
  84.       (if doc
  85.       (progn (setq obj (cdr obj))
  86.          (write-spaces indent stream)
  87.          (princ " doc: " stream)
  88.          (princ doc stream)
  89.          (terpri stream))))
  90.     (write-spaces indent stream)
  91.     (princ " args: " stream)
  92.     (prin1 args stream)
  93.     (terpri stream)
  94.     (let ((interactive (car (cdr (assq 'interactive obj)))))
  95.       (if interactive
  96.       (progn (write-spaces indent stream)
  97.          (princ " interactive: " stream)
  98.          (if (eq (car-safe interactive) 'byte-code)
  99.              (disassemble-1 interactive stream
  100.                (+ indent disassemble-recursive-indent))
  101.            (prin1 interactive stream)
  102.            (terpri stream)))))
  103.     (setq obj (assq 'byte-code obj))    ;obj is now call to byte-code
  104.     (disassemble-1 obj stream indent))
  105.   (if interactive-p
  106.       (message "")))
  107.  
  108. (defun disassemble-1 (obj &optional stream indent)
  109.   "Prints the byte-code call OBJ to (optional) STREAM.
  110. OBJ should be a call to BYTE-CODE generated by the byte compiler."
  111.   (or indent (setq indent 0))        ;default indent to 0
  112.   (or stream (setq stream standard-output))
  113.   (let ((bytes (car (cdr obj)))        ;the byte code
  114.     (ptr -1)            ;where we are in it
  115.     (constants (car (cdr (cdr obj)))) ;constant vector
  116.     ;(next-indent indent)
  117.     offset tmp length)
  118.     (setq length (length bytes))
  119.     (terpri stream)
  120.     (while (< (setq ptr (1+ ptr)) length)
  121.       ;(setq indent next-indent)
  122.       (write-spaces indent stream)    ;indent to recursive indent
  123.       (princ (setq tmp (prin1-to-string ptr)) stream) ;print line #
  124.       (write-char ?\  stream)
  125.       (write-spaces (- disassemble-column-1-indent (length tmp) 1)
  126.             stream)
  127.       (setq op (aref bytes ptr))    ;fetch opcode
  128.       ;; Note: as offsets are either encoded in opcodes or stored as
  129.       ;; bytes in the code, this function (disassemble-offset)
  130.       ;; can set OP and/or PTR.
  131.       (setq offset (disassemble-offset));fetch offset
  132.       (setq tmp (aref byte-code-vector op))
  133.       (if (consp tmp)
  134.       (setq ;next-indent (if (numberp (cdr tmp))
  135.         ;        (+ indent (cdr tmp))
  136.         ;          (+ indent (funcall (cdr tmp) offset)))
  137.         tmp (car tmp)))
  138.       (setq tmp (symbol-name tmp))
  139.       (princ tmp stream)        ;print op-name for opcode
  140.       (if (null offset)
  141.       nil
  142.     (write-char ?\  stream)
  143.     (write-spaces (- disassemble-column-2-indent (length tmp) 1)
  144.               stream)        ;indent to col 2
  145.     (princ                ;print offset
  146.      (cond ((or (eq op byte-varref)
  147.             (eq op byte-varset)
  148.             (eq op byte-varbind))
  149.         ;; it's a varname (atom)
  150.         (aref constants offset)) ;fetch it from constants
  151.            ((or (eq op byte-goto)
  152.             (eq op byte-goto-if-nil)
  153.             (eq op byte-goto-if-not-nil)
  154.             (eq op byte-goto-if-nil-else-pop)
  155.             (eq op byte-goto-if-not-nil-else-pop)
  156.             (eq op byte-call)
  157.             (eq op byte-unbind))
  158.         ;; it's a number
  159.         offset)            ;return it
  160.            ((or (eq op byte-constant)
  161.             (eq op byte-constant2))
  162.         ;; it's a constant
  163.         (setq tmp (aref constants offset))
  164.         ;; but is constant byte code?
  165.         (cond ((and (eq (car-safe tmp) 'lambda)
  166.                 (assq 'byte-code tmp))
  167.                (princ "<compiled lambda>" stream)
  168.                (terpri stream)
  169.                (disassemble    ;recurse on compiled lambda
  170.              tmp
  171.              stream
  172.              (+ indent disassemble-recursive-indent))
  173.                "")
  174.               ((eq (car-safe tmp) 'byte-code)
  175.                (princ "<byte code>" stream)
  176.                (terpri stream)
  177.                (disassemble-1    ;recurse on byte-code object
  178.              tmp
  179.              stream
  180.              (+ indent disassemble-recursive-indent))
  181.                "")
  182.               ((eq (car-safe (car-safe tmp)) 'byte-code)
  183.                (princ "(<byte code>...)" stream)
  184.                (terpri stream)
  185.                (mapcar        ;recurse on list of byte-code objects
  186.              (function (lambda (obj)
  187.                      (disassemble-1
  188.                        obj
  189.                        stream
  190.                        (+ indent disassemble-recursive-indent))))
  191.              tmp)
  192.                "")
  193.               ((and (eq tmp 'byte-code) 
  194.                 (eq (aref bytes (+ ptr 4)) (+ byte-call 3)))
  195.                ;; this won't catch cases where args are pushed w/
  196.                ;; constant2.
  197.                (setq ptr (+ ptr 4))
  198.                "<compiled call to byte-code.  compiled code compiled?>")
  199.               (t
  200.                ;; really just a constant
  201.                (let ((print-escape-newlines t))
  202.              (prin1-to-string tmp)))))
  203.            (t "<error in disassembler>"))
  204.      stream))
  205.       (terpri stream)))
  206.   nil)
  207.  
  208.  
  209. (defun disassemble-offset ()
  210.   "Don't call this!"
  211.   ;; fetch and return the offset for the current opcode.
  212.   ;; return NIL if this opcode has no offset
  213.   ;; OP, PTR and BYTES are used and set dynamically
  214.   (let (tem)
  215.     (cond ((< op byte-nth)
  216.        (setq tem (logand op 7))
  217.        (setq op (logand op 248))
  218.        (cond ((eq tem 6)
  219.           (setq ptr (1+ ptr))    ;offset in next byte
  220.           (aref bytes ptr))
  221.          ((eq tem 7)
  222.           (setq ptr (1+ ptr))    ;offset in next 2 bytes
  223.           (+ (aref bytes ptr)
  224.              (progn (setq ptr (1+ ptr))
  225.                 (lsh (aref bytes ptr) 8))))
  226.          (t tem)))    ;offset was in opcode
  227.       ((>= op byte-constant)
  228.        (setq tem (- op byte-constant)) ;offset in opcode
  229.        (setq op byte-constant)
  230.        tem)
  231.       ((or (= op byte-constant2)
  232.            (and (>= op byte-goto)
  233.             (<= op byte-goto-if-not-nil-else-pop)))
  234.        (setq ptr (1+ ptr))        ;offset in next 2 bytes
  235.        (+ (aref bytes ptr)
  236.           (progn (setq ptr (1+ ptr))
  237.              (lsh (aref bytes ptr) 8))))
  238.       (t nil))))            ;no offset
  239.  
  240.  
  241. (defun write-spaces (n &optional stream)
  242.   "Print N spaces to (opti